home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / RXCOMBOS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  23.0 KB  |  887 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11.  
  12. unit RxCombos;
  13.  
  14. {.$DEFINE GXE}
  15. { Activate this define to use RxCombos in the GXExplorer Open Source project }
  16.  
  17. {$I RX.INC}
  18. {$W-,T-}
  19.  
  20. interface
  21.  
  22. uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  23.   Messages, Classes, Controls, Graphics, StdCtrls, Forms, Menus;
  24.  
  25. type
  26.  
  27. { TOwnerDrawComboBox }
  28.  
  29.   TOwnerDrawComboStyle = csDropDown..csDropDownList;
  30.  
  31.   TOwnerDrawComboBox = class(TCustomComboBox)
  32.   private
  33.     FStyle: TOwnerDrawComboStyle;
  34.     FItemHeightChanging: Boolean;
  35.     procedure SetComboStyle(Value: TOwnerDrawComboStyle);
  36.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  37. {$IFDEF RX_D3}
  38.     procedure CMRecreateWnd(var Message: TMessage); message CM_RECREATEWND;
  39. {$ENDIF}
  40.   protected
  41.     procedure CreateParams(var Params: TCreateParams); override;
  42.     procedure CreateWnd; override;
  43.     procedure ResetItemHeight;
  44.     function MinItemHeight: Integer; virtual;
  45.     property Style: TOwnerDrawComboStyle read FStyle write SetComboStyle
  46.       default csDropDownList;
  47.   public
  48.     constructor Create(AOwner: TComponent); override;
  49.   end;
  50.  
  51. { TColorComboBox }
  52.  
  53. {$IFDEF RX_D3}
  54.   TColorComboOption = (coIncludeDefault, coIncludeNone);
  55.   TColorComboOptions = set of TColorComboOption;
  56. {$ENDIF}
  57.  
  58.   TColorComboBox = class(TOwnerDrawComboBox)
  59.   private
  60.     FColorValue: TColor;
  61.     FDisplayNames: Boolean;
  62.     FColorNames: TStrings;
  63. {$IFDEF RX_D3}
  64.     FOptions: TColorComboOptions;
  65. {$ENDIF}
  66.     FOnChange: TNotifyEvent;
  67.     function GetColorValue: TColor;
  68.     procedure SetColorValue(NewValue: TColor);
  69.     procedure SetDisplayNames(Value: Boolean);
  70.     procedure SetColorNames(Value: TStrings);
  71. {$IFDEF RX_D3}
  72.     procedure SetOptions(Value: TColorComboOptions);
  73. {$ENDIF}
  74.     procedure ColorNamesChanged(Sender: TObject);
  75.   protected
  76.     procedure CreateWnd; override;
  77.     procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
  78.     procedure Click; override;
  79.     procedure Change; override;
  80.     procedure PopulateList; virtual;
  81.     procedure DoChange; dynamic;
  82.   public
  83.     constructor Create(AOwner: TComponent); override;
  84.     destructor Destroy; override;
  85.     property Text;
  86.   published
  87.     property ColorValue: TColor read GetColorValue write SetColorValue
  88.       default clBlack;
  89.     property ColorNames: TStrings read FColorNames write SetColorNames;
  90.     property DisplayNames: Boolean read FDisplayNames write SetDisplayNames
  91.       default True;
  92. {$IFDEF RX_D3}
  93.     property Options: TColorComboOptions read FOptions write SetOptions
  94.       default [];
  95. {$ENDIF}
  96.     property Color;
  97.     property Ctl3D;
  98.     property DragMode;
  99.     property DragCursor;
  100.     property Enabled;
  101.     property Font;
  102. {$IFDEF RX_D4}
  103.     property Anchors;
  104.     property BiDiMode;
  105.     property Constraints;
  106.     property DragKind;
  107.     property ParentBiDiMode;
  108. {$ENDIF}
  109. {$IFDEF WIN32}
  110.   {$IFNDEF VER90}
  111.     property ImeMode;
  112.     property ImeName;
  113.   {$ENDIF}
  114. {$ENDIF}
  115.     property ParentColor;
  116.     property ParentCtl3D;
  117.     property ParentFont;
  118.     property ParentShowHint;
  119.     property PopupMenu;
  120.     property ShowHint;
  121.     property Style;
  122.     property TabOrder;
  123.     property TabStop;
  124.     property Visible;
  125.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  126.     property OnClick;
  127.     property OnDblClick;
  128.     property OnDragDrop;
  129.     property OnDragOver;
  130.     property OnDropDown;
  131.     property OnEndDrag;
  132.     property OnEnter;
  133.     property OnExit;
  134.     property OnKeyDown;
  135.     property OnKeyPress;
  136.     property OnKeyUp;
  137. {$IFDEF WIN32}
  138.     property OnStartDrag;
  139. {$ENDIF}
  140. {$IFDEF RX_D5}
  141.     property OnContextPopup;
  142. {$ENDIF}
  143. {$IFDEF RX_D4}
  144.     property OnEndDock;
  145.     property OnStartDock;
  146. {$ENDIF}
  147.   end;
  148.  
  149. { TFontComboBox }
  150.  
  151.   TFontDevice = (fdScreen, fdPrinter, fdBoth);
  152.   TFontListOption = (foAnsiOnly, foTrueTypeOnly, foFixedPitchOnly,
  153.     foNoOEMFonts, foOEMFontsOnly, foScalableOnly, foNoSymbolFonts);
  154.   TFontListOptions = set of TFontListOption;
  155.  
  156.   TFontComboBox = class(TOwnerDrawComboBox)
  157.   private
  158.     FTrueTypeBMP: TBitmap;
  159.     FDeviceBMP: TBitmap;
  160.     FOnChange: TNotifyEvent;
  161.     FDevice: TFontDevice;
  162.     FUpdate: Boolean;
  163.     FUseFonts: Boolean;
  164.     FOptions: TFontListOptions;
  165.     procedure SetFontName(const NewFontName: TFontName);
  166.     function GetFontName: TFontName;
  167.     function GetTrueTypeOnly: Boolean;
  168.     procedure SetDevice(Value: TFontDevice);
  169.     procedure SetOptions(Value: TFontListOptions);
  170.     procedure SetTrueTypeOnly(Value: Boolean);
  171.     procedure SetUseFonts(Value: Boolean);
  172.     procedure Reset;
  173.     procedure WMFontChange(var Message: TMessage); message WM_FONTCHANGE;
  174.   protected
  175.     procedure PopulateList; virtual;
  176.     procedure Change; override;
  177.     procedure Click; override;
  178.     procedure DoChange; dynamic;
  179.     procedure CreateWnd; override;
  180.     procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
  181.     function MinItemHeight: Integer; override;
  182.   public
  183.     constructor Create(AOwner: TComponent); override;
  184.     destructor Destroy; override;
  185.     property Text;
  186.   published
  187.     property Device: TFontDevice read FDevice write SetDevice default fdScreen;
  188.     property FontName: TFontName read GetFontName write SetFontName;
  189.     property Options: TFontListOptions read FOptions write SetOptions default [];
  190.     property TrueTypeOnly: Boolean read GetTrueTypeOnly write SetTrueTypeOnly
  191.       stored False; { obsolete, use Options instead }
  192.     property UseFonts: Boolean read FUseFonts write SetUseFonts default False;
  193.     property Color;
  194.     property Ctl3D;
  195.     property DragMode;
  196.     property DragCursor;
  197.     property Enabled;
  198.     property Font;
  199. {$IFDEF RX_D4}
  200.     property Anchors;
  201.     property BiDiMode;
  202.     property Constraints;
  203.     property DragKind;
  204.     property ParentBiDiMode;
  205. {$ENDIF}
  206. {$IFDEF WIN32}
  207.   {$IFNDEF VER90}
  208.     property ImeMode;
  209.     property ImeName;
  210.   {$ENDIF}
  211. {$ENDIF}
  212.     property ParentColor;
  213.     property ParentCtl3D;
  214.     property ParentFont;
  215.     property ParentShowHint;
  216.     property PopupMenu;
  217.     property ShowHint;
  218.     property Style;
  219.     property TabOrder;
  220.     property TabStop;
  221.     property Visible;
  222.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  223.     property OnClick;
  224.     property OnDblClick;
  225.     property OnDragDrop;
  226.     property OnDragOver;
  227.     property OnDropDown;
  228.     property OnEndDrag;
  229.     property OnEnter;
  230.     property OnExit;
  231.     property OnKeyDown;
  232.     property OnKeyPress;
  233.     property OnKeyUp;
  234. {$IFDEF WIN32}
  235.     property OnStartDrag;
  236. {$ENDIF}
  237. {$IFDEF RX_D5}
  238.     property OnContextPopup;
  239. {$ENDIF}
  240. {$IFDEF RX_D4}
  241.     property OnEndDock;
  242.     property OnStartDock;
  243. {$ENDIF}
  244.   end;
  245.  
  246. {$IFDEF GXE}
  247. procedure Register;
  248. {$ENDIF}
  249.  
  250. implementation
  251.  
  252. {$IFDEF WIN32}
  253.  {$R *.R32}
  254. {$ELSE}
  255.  {$R *.R16}
  256. {$ENDIF}
  257.  
  258. uses SysUtils, Consts, Printers {$IFNDEF GXE}, VCLUtils {$ENDIF};
  259.  
  260. {$IFDEF GXE}
  261. procedure Register;
  262. begin
  263.   RegisterComponents('Additional', [TFontComboBox, TColorComboBox]);
  264. end;
  265. {$ENDIF GXE}
  266.  
  267. {$IFNDEF WIN32}
  268. type
  269.   DWORD = Longint;
  270. {$ENDIF}
  271.  
  272. { Utility routines }
  273.  
  274. function CreateBitmap(ResName: PChar): TBitmap;
  275. begin
  276. {$IFDEF GXE}
  277.   Result := TBitmap.Create;
  278.   Result.Handle := LoadBitmap(HInstance, ResName);
  279. {$ELSE}
  280.   Result := MakeModuleBitmap(HInstance, ResName);
  281.   if Result = nil then ResourceNotFound(ResName);
  282. {$ENDIF GXE}
  283. end;
  284.  
  285. function GetItemHeight(Font: TFont): Integer;
  286. var
  287.   DC: HDC;
  288.   SaveFont: HFont;
  289.   Metrics: TTextMetric;
  290. begin
  291.   DC := GetDC(0);
  292.   try
  293.     SaveFont := SelectObject(DC, Font.Handle);
  294.     GetTextMetrics(DC, Metrics);
  295.     SelectObject(DC, SaveFont);
  296.   finally
  297.     ReleaseDC(0, DC);
  298.   end;
  299.   Result := Metrics.tmHeight + 1;
  300. end;
  301.  
  302. { TOwnerDrawComboBox }
  303.  
  304. constructor TOwnerDrawComboBox.Create(AOwner: TComponent);
  305. begin
  306.   inherited Create(AOwner);
  307.   inherited Style := csDropDownList;
  308.   FStyle := csDropDownList;
  309. end;
  310.  
  311. procedure TOwnerDrawComboBox.SetComboStyle(Value: TOwnerDrawComboStyle);
  312. begin
  313.   if FStyle <> Value then begin
  314.     FStyle := Value;
  315.     inherited Style := Value;
  316.   end;
  317. end;
  318.  
  319. function TOwnerDrawComboBox.MinItemHeight: Integer;
  320. begin
  321.   Result := GetItemHeight(Font);
  322.   if Result < 9 then Result := 9;
  323. end;
  324.  
  325. procedure TOwnerDrawComboBox.ResetItemHeight;
  326. var
  327.   H: Integer;
  328. begin
  329.   H := MinItemHeight;
  330.   FItemHeightChanging := True;
  331.   try
  332.     inherited ItemHeight := H;
  333.   finally
  334.     FItemHeightChanging := False;
  335.   end;
  336.   if HandleAllocated then SendMessage(Handle, CB_SETITEMHEIGHT, 0, H);
  337. end;
  338.  
  339. procedure TOwnerDrawComboBox.CreateParams(var Params: TCreateParams);
  340. const
  341.   ComboBoxStyles: array[TOwnerDrawComboStyle] of DWORD =
  342.     (CBS_DROPDOWN, CBS_SIMPLE, CBS_DROPDOWNLIST);
  343. begin
  344.   inherited CreateParams(Params);
  345.   with Params do
  346.     Style := (Style and not CBS_DROPDOWNLIST) or CBS_OWNERDRAWFIXED or
  347.       ComboBoxStyles[FStyle];
  348. end;
  349.  
  350. procedure TOwnerDrawComboBox.CreateWnd;
  351. begin
  352.   inherited CreateWnd;
  353.   ResetItemHeight;
  354. end;
  355.  
  356. procedure TOwnerDrawComboBox.CMFontChanged(var Message: TMessage);
  357. begin
  358.   inherited;
  359.   ResetItemHeight;
  360.   RecreateWnd;
  361. end;
  362.  
  363. {$IFDEF RX_D3}
  364. procedure TOwnerDrawComboBox.CMRecreateWnd(var Message: TMessage);
  365. begin
  366.   if not FItemHeightChanging then
  367.     inherited;
  368. end;
  369. {$ENDIF}
  370.  
  371. { TColorComboBox }
  372.  
  373. const
  374.   ColorsInList = {$IFDEF RX_D3} 18 {$ELSE} 16 {$ENDIF};
  375.   ColorValues: array [0..ColorsInList - 1] of TColor = (
  376.     clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clGray,
  377.     clSilver, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite
  378.     {$IFDEF RX_D3}, clNone, clDefault {$ENDIF});
  379.  
  380. constructor TColorComboBox.Create(AOwner: TComponent);
  381. begin
  382.   inherited Create(AOwner);
  383.   FColorValue := clBlack;  { make default color selected }
  384.   FColorNames := TStringList.Create;
  385.   TStringList(FColorNames).OnChange := ColorNamesChanged;
  386.   FDisplayNames := True;
  387. end;
  388.  
  389. destructor TColorComboBox.Destroy;
  390. begin
  391.   TStringList(FColorNames).OnChange := nil;
  392.   FColorNames.Free;
  393.   FColorNames := nil;
  394.   inherited Destroy;
  395. end;
  396.  
  397. procedure TColorComboBox.CreateWnd;
  398. begin
  399.   inherited CreateWnd;
  400.   PopulateList;
  401.   SetColorValue(FColorValue);
  402. end;
  403.  
  404. procedure TColorComboBox.PopulateList;
  405. var
  406.   I: Integer;
  407.   ColorName: string;
  408. begin
  409.   Items.BeginUpdate;
  410.   try
  411.     Clear;
  412.     for I := 0 to Pred(ColorsInList) do begin
  413. {$IFDEF RX_D3}
  414.       if ((ColorValues[I] = clDefault) and not (coIncludeDefault in Options)) or
  415.         ((ColorValues[I] = clNone) and not (coIncludeNone in Options)) then
  416.         Continue;
  417. {$ENDIF}
  418.       if (I <= Pred(FColorNames.Count)) and (FColorNames[I] <> '') then
  419.         ColorName := FColorNames[I]
  420. {$IFDEF RX_D3}
  421.       else if ColorValues[I] = clDefault then ColorName := SDefault
  422. {$ENDIF}
  423.       else
  424.         { delete two first characters which prefix "cl" educated }
  425.         ColorName := Copy(ColorToString(ColorValues[I]), 3, MaxInt);
  426.       Items.AddObject(ColorName, TObject(ColorValues[I]));
  427.     end;
  428.   finally
  429.     Items.EndUpdate;
  430.   end;
  431. end;
  432.  
  433. procedure TColorComboBox.ColorNamesChanged(Sender: TObject);
  434. begin
  435.   if HandleAllocated then begin
  436.     FColorValue := ColorValue;
  437.     RecreateWnd;
  438.   end;
  439. end;
  440.  
  441. procedure TColorComboBox.SetColorNames(Value: TStrings);
  442. begin
  443.   FColorNames.Assign(Value);
  444. end;
  445.  
  446. procedure TColorComboBox.SetDisplayNames(Value: Boolean);
  447. begin
  448.   if DisplayNames <> Value then begin
  449.     FDisplayNames := Value;
  450.     Invalidate;
  451.   end;
  452. end;
  453.  
  454. {$IFDEF RX_D3}
  455. procedure TColorComboBox.SetOptions(Value: TColorComboOptions);
  456. begin
  457.   if FOptions <> Value then begin
  458.     FOptions := Value;
  459.     if HandleAllocated then RecreateWnd;
  460.   end;
  461. end;
  462. {$ENDIF}
  463.  
  464. function TColorComboBox.GetColorValue: TColor;
  465. var
  466.   I: Integer;
  467. begin
  468.   Result := FColorValue;
  469.   if (Style <> csDropDownList) and (ItemIndex < 0) then begin
  470.     I := Items.IndexOf(inherited Text);
  471.     if I >= 0 then Result := TColor(Items.Objects[I])
  472.     else begin
  473.       Val(inherited Text, Result, I);
  474.       if I <> 0 then Result := FColorValue;
  475.     end;
  476.   end;
  477. end;
  478.  
  479. procedure TColorComboBox.SetColorValue(NewValue: TColor);
  480. var
  481.   Item: Integer;
  482.   CurrentColor: TColor;
  483.   S: string;
  484. begin
  485.   if (ItemIndex < 0) or (NewValue <> FColorValue) then begin
  486.     FColorValue := NewValue;
  487.     { change selected item }
  488.     for Item := 0 to Pred(Items.Count) do begin
  489.       CurrentColor := TColor(Items.Objects[Item]);
  490.       if CurrentColor = NewValue then begin
  491.         if ItemIndex <> Item then ItemIndex := Item;
  492.         DoChange;
  493.         Exit;
  494.       end;
  495.     end;
  496.     if Style = csDropDownList then
  497.       ItemIndex := -1
  498.     else begin
  499.       S := ColorToString(NewValue);
  500.       if Pos('cl', S) = 1 then System.Delete(S, 1, 2);
  501.       inherited Text := S;
  502.     end;
  503.     DoChange;
  504.   end;
  505. end;
  506.  
  507. procedure TColorComboBox.DrawItem(Index: Integer; Rect: TRect;
  508.   State: TOwnerDrawState);
  509.  
  510.   function ColorToBorderColor(AColor: TColor): TColor;
  511.   type
  512.     TColorQuad = record
  513.       Red, Green, Blue, Alpha: Byte;
  514.     end;
  515.   begin
  516.     if (TColorQuad(AColor).Red > 192) or (TColorQuad(AColor).Green > 192) or
  517.        (TColorQuad(AColor).Blue > 192) then
  518.       Result := clBlack
  519.     else if (odSelected in State) then
  520.       Result := clWhite
  521.     else
  522.       Result := AColor;
  523.   end;
  524.  
  525. const
  526.   ColorWidth = 22;
  527. var
  528.   ARect: TRect;
  529.   Text: array[0..255] of Char;
  530.   Safer: TColor;
  531. begin
  532.   ARect := Rect;
  533.   Inc(ARect.Top, 2);
  534.   Inc(ARect.Left, 2);
  535.   Dec(ARect.Bottom, 2);
  536.   if FDisplayNames then ARect.Right := ARect.Left + ColorWidth
  537.   else Dec(ARect.Right, 3);
  538.   with Canvas do begin
  539.     FillRect(Rect);
  540.     Safer := Brush.Color;
  541.     Pen.Color := ColorToBorderColor(ColorToRGB(TColor(Items.Objects[Index])));
  542.     Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
  543.     Brush.Color := TColor(Items.Objects[Index]);
  544.     try
  545.       InflateRect(ARect, -1, -1);
  546.       FillRect(ARect);
  547.     finally
  548.       Brush.Color := Safer;
  549.     end;
  550.     if FDisplayNames then begin
  551.       StrPCopy(Text, Items[Index]);
  552.       Rect.Left := Rect.Left + ColorWidth + 6;
  553.       DrawText(Canvas.Handle, Text, StrLen(Text), Rect,
  554. {$IFDEF RX_D4}
  555.         DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX));
  556. {$ELSE}
  557.         DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
  558. {$ENDIF}
  559.     end;
  560.   end;
  561. end;
  562.  
  563. procedure TColorComboBox.Change;
  564. var
  565.   AColor: TColor;
  566. begin
  567.   inherited Change;
  568.   AColor := GetColorValue;
  569.   if FColorValue <> AColor then begin
  570.     FColorValue := AColor;
  571.     DoChange;
  572.   end;
  573. end;
  574.  
  575. procedure TColorComboBox.Click;
  576. begin
  577.   if ItemIndex >= 0 then ColorValue := TColor(Items.Objects[ItemIndex]);
  578.   inherited Click;
  579. end;
  580.  
  581. procedure TColorComboBox.DoChange;
  582. begin
  583.   if not (csReading in ComponentState) then
  584.     if Assigned(FOnChange) then FOnChange(Self);
  585. end;
  586.  
  587. { TFontComboBox }
  588.  
  589. const
  590.   WRITABLE_FONTTYPE = 256;
  591.  
  592. function IsValidFont(Box: TFontComboBox; LogFont: TLogFont;
  593.   FontType: Integer): Boolean;
  594. begin
  595.   Result := True;
  596.   if (foAnsiOnly in Box.Options) then
  597.     Result := Result and (LogFont.lfCharSet = ANSI_CHARSET);
  598.   if (foTrueTypeOnly in Box.Options) then
  599.     Result := Result and (FontType and TRUETYPE_FONTTYPE = TRUETYPE_FONTTYPE);
  600.   if (foFixedPitchOnly in Box.Options) then
  601.     Result := Result and (LogFont.lfPitchAndFamily and FIXED_PITCH = FIXED_PITCH);
  602.   if (foOEMFontsOnly in Box.Options) then
  603.     Result := Result and (LogFont.lfCharSet = OEM_CHARSET);
  604.   if (foNoOEMFonts in Box.Options) then
  605.     Result := Result and (LogFont.lfCharSet <> OEM_CHARSET);
  606.   if (foNoSymbolFonts in Box.Options) then
  607.     Result := Result and (LogFont.lfCharSet <> SYMBOL_CHARSET);
  608.   if (foScalableOnly in Box.Options) then
  609.     Result := Result and (FontType and RASTER_FONTTYPE = 0);
  610. end;
  611.  
  612. {$IFDEF WIN32}
  613.  
  614. function EnumFontsProc(var EnumLogFont: TEnumLogFont;
  615.   var TextMetric: TNewTextMetric; FontType: Integer; Data: LPARAM): Integer;
  616.   export; stdcall;
  617. var
  618.   FaceName: string;
  619. begin
  620.   FaceName := StrPas(EnumLogFont.elfLogFont.lfFaceName);
  621.   with TFontComboBox(Data) do
  622.     if (Items.IndexOf(FaceName) < 0) and
  623.       IsValidFont(TFontComboBox(Data), EnumLogFont.elfLogFont, FontType) then
  624.     begin
  625.       if EnumLogFont.elfLogFont.lfCharSet <> SYMBOL_CHARSET then
  626.         FontType := FontType or WRITABLE_FONTTYPE;
  627.       Items.AddObject(FaceName, TObject(FontType));
  628.     end;
  629.   Result := 1;
  630. end;
  631.  
  632. {$ELSE}
  633.  
  634. function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  635.   FontType: Integer; Data: Pointer): Integer; export;
  636. begin
  637.   with TFontComboBox(Data) do
  638.     if (Items.IndexOf(StrPas(LogFont.lfFaceName)) < 0) and
  639.       IsValidFont(TFontComboBox(Data), LogFont, FontType) then
  640.     begin
  641.       if LogFont.lfCharSet = SYMBOL_CHARSET then
  642.         FontType := FontType or WRITABLE_FONTTYPE;
  643.       Items.AddObject(StrPas(LogFont.lfFaceName), TObject(FontType));
  644.     end;
  645.   Result := 1;
  646. end;
  647.  
  648. {$ENDIF WIN32}
  649.  
  650. constructor TFontComboBox.Create(AOwner: TComponent);
  651. begin
  652.   inherited Create(AOwner);
  653.   FTrueTypeBMP := CreateBitmap('TRUETYPE_FNT');
  654.   FDeviceBMP := CreateBitmap('DEVICE_FNT');
  655.   FDevice := fdScreen;
  656.   Sorted := True;
  657.   inherited ItemHeight := MinItemHeight;
  658. end;
  659.  
  660. destructor TFontComboBox.Destroy;
  661. begin
  662.   FTrueTypeBMP.Free;
  663.   FDeviceBMP.Free;
  664.   inherited Destroy;
  665. end;
  666.  
  667. procedure TFontComboBox.CreateWnd;
  668. var
  669.   OldFont: TFontName;
  670. begin
  671.   OldFont := FontName;
  672.   inherited CreateWnd;
  673.   FUpdate := True;
  674.   try
  675.     PopulateList;
  676.     inherited Text := '';
  677.     SetFontName(OldFont);
  678.   finally
  679.     FUpdate := False;
  680.   end;
  681.   if AnsiCompareText(FontName, OldFont) <> 0 then DoChange;
  682. end;
  683.  
  684. procedure TFontComboBox.PopulateList;
  685. var
  686.   DC: HDC;
  687. {$IFNDEF WIN32}
  688.   Proc: TFarProc;
  689. {$ENDIF}
  690. begin
  691.   if not HandleAllocated then Exit;
  692.   Items.BeginUpdate;
  693.   try
  694.     Clear;
  695.     DC := GetDC(0);
  696.     try
  697. {$IFDEF WIN32}
  698.       if (FDevice = fdScreen) or (FDevice = fdBoth) then
  699.         EnumFontFamilies(DC, nil, @EnumFontsProc, Longint(Self));
  700.       if (FDevice = fdPrinter) or (FDevice = fdBoth) then
  701.       try
  702.         EnumFontFamilies(Printer.Handle, nil, @EnumFontsProc, Longint(Self));
  703.       except
  704.         { skip any errors }
  705.       end;
  706. {$ELSE}
  707.       Proc := MakeProcInstance(@EnumFontsProc, HInstance);
  708.       try
  709.         if (FDevice = fdScreen) or (FDevice = fdBoth) then
  710.           EnumFonts(DC, nil, Proc, PChar(Self));
  711.         if (FDevice = fdPrinter) or (FDevice = fdBoth) then
  712.           try
  713.             EnumFonts(Printer.Handle, nil, Proc, PChar(Self));
  714.           except
  715.             { skip any errors }
  716.           end;
  717.       finally
  718.         FreeProcInstance(Proc);
  719.       end;
  720. {$ENDIF}
  721.     finally
  722.       ReleaseDC(0, DC);
  723.     end;
  724.   finally
  725.     Items.EndUpdate;
  726.   end;
  727. end;
  728.  
  729. procedure TFontComboBox.SetFontName(const NewFontName: TFontName);
  730. var
  731.   Item: Integer;
  732. begin
  733.   if FontName <> NewFontName then begin
  734.     if not (csLoading in ComponentState) then begin
  735.       HandleNeeded;
  736.       { change selected item }
  737.       for Item := 0 to Items.Count - 1 do
  738.         if AnsiCompareText(Items[Item], NewFontName) = 0 then begin
  739.           ItemIndex := Item;
  740.           DoChange;
  741.           Exit;
  742.         end;
  743.       if Style = csDropDownList then ItemIndex := -1
  744.       else inherited Text := NewFontName;
  745.     end
  746.     else inherited Text := NewFontName;
  747.     DoChange;
  748.   end;
  749. end;
  750.  
  751. function TFontComboBox.GetFontName: TFontName;
  752. begin
  753.   Result := inherited Text;
  754. end;
  755.  
  756. function TFontComboBox.GetTrueTypeOnly: Boolean;
  757. begin
  758.   Result := foTrueTypeOnly in FOptions;
  759. end;
  760.  
  761. procedure TFontComboBox.SetOptions(Value: TFontListOptions);
  762. begin
  763.   if Value <> Options then begin
  764.     FOptions := Value;
  765.     Reset;
  766.   end;
  767. end;
  768.  
  769. procedure TFontComboBox.SetTrueTypeOnly(Value: Boolean);
  770. begin
  771.   if Value <> TrueTypeOnly then begin
  772.     if Value then FOptions := FOptions + [foTrueTypeOnly]
  773.     else FOptions := FOptions - [foTrueTypeOnly];
  774.     Reset;
  775.   end;
  776. end;
  777.  
  778. procedure TFontComboBox.SetDevice(Value: TFontDevice);
  779. begin
  780.   if Value <> FDevice then begin
  781.     FDevice := Value;
  782.     Reset;
  783.   end;
  784. end;
  785.  
  786. procedure TFontComboBox.SetUseFonts(Value: Boolean);
  787. begin
  788.   if Value <> FUseFonts then begin
  789.     FUseFonts := Value;
  790.     Invalidate;
  791.   end;
  792. end;
  793.  
  794. procedure TFontComboBox.DrawItem(Index: Integer; Rect: TRect;
  795.   State: TOwnerDrawState);
  796. var
  797.   Bitmap: TBitmap;
  798.   BmpWidth: Integer;
  799.   Text: array[0..255] of Char;
  800. begin
  801.   with Canvas do begin
  802.     FillRect(Rect);
  803.     BmpWidth  := 20;
  804.     if (Integer(Items.Objects[Index]) and TRUETYPE_FONTTYPE) <> 0 then
  805.       Bitmap := FTrueTypeBMP
  806.     else if (Integer(Items.Objects[Index]) and DEVICE_FONTTYPE) <> 0 then
  807.       Bitmap := FDeviceBMP
  808.     else Bitmap := nil;
  809.     if Bitmap <> nil then begin
  810.       BmpWidth := Bitmap.Width;
  811.       BrushCopy(Bounds(Rect.Left + 2, (Rect.Top + Rect.Bottom - Bitmap.Height)
  812.         div 2, Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
  813.         Bitmap.Height), Bitmap.TransparentColor);
  814.     end;
  815.     { uses DrawText instead of TextOut in order to get clipping against
  816.       the combo box button }
  817.     {TextOut(Rect.Left + bmpWidth + 6, Rect.Top, Items[Index])}
  818.     StrPCopy(Text, Items[Index]);
  819.     Rect.Left := Rect.Left + BmpWidth + 6;
  820.     if FUseFonts and (Integer(Items.Objects[Index]) and WRITABLE_FONTTYPE <> 0) then
  821.       Font.Name := Items[Index];
  822.     DrawText(Handle, Text, StrLen(Text), Rect,
  823. {$IFDEF RX_D4}
  824.       DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX));
  825. {$ELSE}
  826.       DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
  827. {$ENDIF}
  828.   end;
  829. end;
  830.  
  831. procedure TFontComboBox.WMFontChange(var Message: TMessage);
  832. begin
  833.   inherited;
  834.   Reset;
  835. end;
  836.  
  837. function TFontComboBox.MinItemHeight: Integer;
  838. begin
  839.   Result := inherited MinItemHeight;
  840.   if Result < FTrueTypeBMP.Height - 1 then
  841.     Result := FTrueTypeBMP.Height - 1;
  842. end;
  843.  
  844. procedure TFontComboBox.Change;
  845. var
  846.   I: Integer;
  847. begin
  848.   inherited Change;
  849.   if Style <> csDropDownList then begin
  850.     I := Items.IndexOf(inherited Text);
  851.     if (I >= 0) and (I <> ItemIndex) then begin
  852.       ItemIndex := I;
  853.       DoChange;
  854.     end;
  855.   end;
  856. end;
  857.  
  858. procedure TFontComboBox.Click;
  859. begin
  860.   inherited Click;
  861.   DoChange;
  862. end;
  863.  
  864. procedure TFontComboBox.DoChange;
  865. begin
  866.   if not (csReading in ComponentState) then
  867.     if not FUpdate and Assigned(FOnChange) then FOnChange(Self);
  868. end;
  869.  
  870. procedure TFontComboBox.Reset;
  871. var
  872.   SaveName: TFontName;
  873. begin
  874.   if HandleAllocated then begin
  875.     FUpdate := True;
  876.     try
  877.       SaveName := FontName;
  878.       PopulateList;
  879.       FontName := SaveName;
  880.     finally
  881.       FUpdate := False;
  882.       if FontName <> SaveName then DoChange;
  883.     end;
  884.   end;
  885. end;
  886.  
  887. end.